COMMENT ⊗   VALID 00012 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	!	expr list => expr array 
C00004 00004	!	begin,cobegin,end,coend,if,for,while,do
C00010 00005	!	case
C00014 00006	! 	decl,simpledecl,arraydecl,procdecl,return
C00025 00007	!	setbase,wrist,gather,readwrist,setstiff
C00030 00008	! 	vt05,print,prompt,abort,sigwait
C00032 00009	!	affix,unfix
C00035 00010	! 	coordproc
C00039 00011	!	assignproc
C00042 00012	! 	deflt
C00043 ENDMK
C⊗;
ENTRY;
BEGIN "PPROC"
DEFINE $$PRGID=TRUE;	DEFINE $PPROC=TRUE;	
REQUIRE "HEADER.SAI" SOURCE_FILE;


RCLASS EXPR$LST(RPTR(EXPR$) PTR; RPTR(EXPR$LST) NEXT);
RCLASS EXPR$ARR(RPTR(EXPR$) ARRAY PTR);

DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];


SIMPLE INTEGER PROCEDURE UPLEVEL(INTEGER OFFSET);
BEGIN
	INTEGER I;
	I ← (OFFSET +1) LSH -8	; ! this gives the level ;
	I ← (I+1) LSH 8		; ! this gives the next level ;
	RETURN(I-1);
END;
!	expr list => expr array ;
RPTR(EXPR$ARR) PROCEDURE ARRIFY(RPTR(EXPR$LST)PTR);
	BEGIN
	! takes a list of EXPR$ records and makes them into an array;
	INTEGER I,NRECS; RPTR(EXPR$LST)PPTR;
	NRECS←0; PPTR←PTR;
	WHILE PPTR DO BEGIN NRECS←NRECS+1; PPTR←EXPR$LST:NEXT[PPTR]; END;
		BEGIN
		RPTR(EXPR$)ARRAY P[1:NRECS];
		RPTR(EXPR$ARR) E;
		PPTR←PTR;
		FOR I←1 STEP 1 UNTIL NRECS DO
			BEGIN
			P[I]←EXPR$LST:PTR[PPTR];
			PPTR←EXPR$LST:NEXT[PPTR];
			END;
		E←NEW_RECORD(EXPR$ARR);
		MEMORY[LOCATION(EXPR$ARR:PTR[E])]↔MEMORY[LOCATION(P)];
		RETURN(E);
		END;
	END;

!	begin,cobegin,end,coend,if,for,while,do;

INTERNAL RECURSIVE PROCEDURE BEGINPROC;
BEGIN
	RPTR(EXPR$LST)E$HEAD,E$CUR; RPTR(BLOCKREC)B;
	INTEGER TMPOFF;
	$COMPILE←$COMPILE+1;
	$LEVEL←$LEVEL+1;
	TMPOFF←$TMPOFF;
	B←NEW_RECORD(BLOCKREC);
	BLOCKREC:NEXT[B]←CURBLOCK;
	CURBLOCK←B;
	E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
	DO BEGIN
		EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST);
		E$CUR←EXPR$LST:NEXT[E$CUR];
		EXPR$LST:PTR[E$CUR]←PARSE;
		GTOKEN;
		IF TOKEN≠";" AND NOT EQU(TOKEN,"END")
			THEN ERROR("Need semicolon to separate statements");
	END UNTIL EQU(TOKEN,"END");
	! kill any new variables defined in this block ;
	EXPR$LST:PTR[EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST)]←
			$KVARPCODE(BLOCKREC:#ARGS[CURBLOCK]);
	$$PCODE←$AAPPEND(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
	CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
	$TMPOFF←TMPOFF;
	$LEVEL←$LEVEL-1;
	$COMPILE←$COMPILE-1;
END;

INTERNAL RECURSIVE PROCEDURE COBEGINPROC;
BEGIN
	RPTR(EXPR$LST)E$HEAD,E$CUR;
	INTEGER TMPOFF,N$TMPOFF;
	$COMPILE←$COMPILE+1;
	$LEVEL←$LEVEL+1;
	TMPOFF←$TMPOFF;
	N$TMPOFF←UPLEVEL($TMPOFF);
	E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
	DO BEGIN
		RPTR(BLOCKREC)B;
		B←NEW_RECORD(BLOCKREC);
		BLOCKREC:NEXT[B]←CURBLOCK;
		CURBLOCK←B;
		$TMPOFF←N$TMPOFF;
		EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST);
		E$CUR←EXPR$LST:NEXT[E$CUR];
		EXPR$LST:PTR[E$CUR]←PARSE;
		CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
		GTOKEN;
		IF TOKEN≠";" AND NOT EQU(TOKEN,"COEND")
			THEN ERROR("Need semicolon to separate statements");
	END UNTIL EQU(TOKEN,"COEND");
	$$PCODE←$COBEGPCODE(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
	$TMPOFF←TMPOFF;
	$LEVEL←$LEVEL-1;
	$COMPILE←$COMPILE-1;
END;

INTERNAL PROCEDURE ENDPROC(STRING E("END"));
BEGIN
	IF $COMPILE=0 THEN ERROR("Encountered "&E&" as a statement.... strange");
	STOKEN←TRUE;
	$$PCODE←NULL_RECORD;
END;

INTERNAL RECURSIVE PROCEDURE IFPROC;
BEGIN
	RPTR(EXPR$)COND,A,B;
	$COMPILE←$COMPILE+1;
	COND←$$GTANYEXP("condition part of IF statement",#SC);
	WORD_READ("THEN");
	A←PARSE;
	GTOKEN;
	B←NULL_RECORD;
	IF EQU(TOKEN,"ELSE") THEN B←PARSE
		ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
		ELSE ERROR("Only ELSE or ; allowed after then part");
	$COMPILE←$COMPILE-1;
	$$PCODE←$IFPCODE(COND,A,B)
END;

INTERNAL RECURSIVE PROCEDURE FORPROC;
BEGIN
	RPTR(SYMBOL)S;
	RPTR(EXPR$)LB,UB,STE,STATE;
	$COMPILE←$COMPILE+1;
	GTOKEN;
	IF TOKENINDEX≠#SC THEN ERROR("Need scalar for FOR statement");
	S←TOKENPTR;
	WORD_READ("←");
	LB←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("STEP");
	STE←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("UNTIL");
	UB←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("DO");
	STATE←PARSE;
	$$PCODE←$FORPCODE(S,LB,STE,UB,STATE);
	$COMPILE←$COMPILE-1;
END;

INTERNAL RECURSIVE PROCEDURE WHILEPROC;
BEGIN
	RPTR(EXPR$)COND,S;
	$COMPILE←$COMPILE+1;
	COND←$$GTANYEXP("condition part of WHILE statement",#SC);
	WORD_READ("DO");
	S←PARSE;
	$COMPILE←$COMPILE-1;
	$$PCODE←$WHILEPCODE(COND,S);
END;

INTERNAL RECURSIVE PROCEDURE DOPROC;
BEGIN
	RPTR(EXPR$)S,COND;
	$COMPILE←$COMPILE+1;
	S←PARSE;
	WORD_READ("UNTIL");
	COND←$$GTANYEXP("UNTIL part of DO statement",#SC);
	$$PCODE←$DOPCODE(S,COND);
	$COMPILE←$COMPILE-1;
END;

!	case;

RECURSIVE RPTR(CASE$) PROCEDURE CASE$REC (RPTR(CASE$)CASEXP;INTEGER NUM);
	BEGIN
	! creates a new record linked with casexp and fills in the
	num field the number num;
	RPTR(CASE$)TEMP;
	TEMP←NEW_RECORD(CASE$);
	CASE$:NEXT[TEMP]←CASEXP;
	CASE$:NUM[TEMP]←NUM;
	RETURN(TEMP);
	END;

RECURSIVE RPTR(CASE$)PROCEDURE CASE$EXP (RPTR(CASE$)CASEXP;RPTR(EXPR$)EXP);
	BEGIN
	! inserts the pointer expr in the field body of casexp;
	IF EXP= NULL!RECORD
	   THEN EXP←EXPR$1(XNOOP);
	CASE$:BODY[CASEXP]←EXP;
	RETURN(CASEXP);
	END;

INTERNAL RECURSIVE PROCEDURE CASEPROC;
	BEGIN
	RPTR(EXPR$)EXINDEX,EXS; RPTR(CASE$)EXCASE;
	BOOLEAN RDELSE;INTEGER MAXNUM;
	$COMPILE←$COMPILE+1;
	RDELSE←FALSE;MAXNUM←-1;
	EXCASE←NULL!RECORD;
	EXINDEX←$$GTANYEXP(" CASE", #SC);	! get index;
	WORD_READ("OF");
	WORD_READ("BEGIN");
	GTOKEN;STOKEN←TRUE;
	IF TOKEN="[" OR EQU(TOKEN,"ELSE")
	   THEN BEGIN "numbered"
		INTEGER NUM;
		DO BEGIN
		   GTOKEN;
		   IF EQU(TOKEN,"ELSE")
			THEN IF RDELSE THEN ERROR ("only one ELSE in CASE!")
				ELSE BEGIN 
				     RDELSE←TRUE;NUM←#ELSE;
				     END
		  	ELSE IF TOKEN="[" 
			   THEN BEGIN
				NUM←POSINT_READ;
				IF NUM>MAXNUM THEN MAXNUM←NUM;
				WORD_READ("]");
				END
			   ELSE ERROR("[ or ELSE expected");
		  ! construct the record with num or #else in field num;
		  EXCASE←CASE$REC(EXCASE,NUM);
		  GTOKEN;
		  STOKEN←TRUE;
		  IF TOKEN≠"[" AND ¬EQU(TOKEN,"ELSE")	
		     THEN BEGIN
			  EXS←PARSE;GTOKEN;
			  IF TOKEN≠";" AND ¬EQU(TOKEN,"END") 
				THEN ERROR("need ; or END");
			  EXCASE←CASE$EXP(EXCASE,EXS);
			  STOKEN←FALSE;
			  END;
		   END UNTIL EQU(TOKEN,"END");
		END "numbered"
		ELSE 
			WHILE ¬EQU(TOKEN,"END") DO 
			BEGIN "unnumbered"
			EXS←PARSE;
			GTOKEN;
			IF TOKEN≠";" AND ¬EQU(TOKEN,"END") 
				THEN ERROR("need ; or END");
			MAXNUM←MAXNUM+1;
	 	 	EXCASE←CASE$EXP(CASE$REC(EXCASE,MAXNUM),EXS);
			END "unnumbered";
	IF MAXNUM≠-1 THEN
		$$PCODE←$CASEPCODE(EXINDEX,EXCASE,RDELSE,MAXNUM);
   	$COMPILE←$COMPILE-1;
   	END;
! 	decl,simpledecl,arraydecl,procdecl,return;

INTERNAL PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
	BEGIN "procedure declaration"
	STRING ATOKEN;INTEGER NARGS,SYMACCS;
	INTEGER TMPOFF;
	INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
	STRING ARRAY ARGNAME[1:10];
	RPTR(SYMBOL) ARRAY SYMARR[1:10];
	RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
	IF CURPROC THEN ERROR("Cant have procedure inside procedure");
	IF CURBLOCK THEN ERROR("Cant have procedure inside block");
	$COMPILE←$COMPILE+1; $LEVEL←1;
	GTOKEN;
	IF #TOKEN≠UNDECLARED_TYPE THEN
		ERROR("Need undeclared identifier for procedure declaration");
	ATOKEN←TOKEN;
	NARGS←0; TMPOFF←$TMPOFF; $TMPOFF←UPLEVEL(TMPOFF);! starting value ;
	GTOKEN;
	IF TOKEN="(" THEN
	    DO BEGIN "procedure with parameters"
		INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
		GTOKEN;
		ARRDECL←FALSE;
		CACCESS←#REFTYP; SYMACCS←#SIMPLE;
		IF EQU(TOKEN,"VALUE") THEN CACCESS←0
			ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
			ELSE STOKEN←TRUE;
		GTOKEN;
		FOR CTYPE←#SC STEP 1 UNTIL #EV DO
			IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
		IF NOT(#SC≤CTYPE≤#EV) THEN ERROR("Need basic data type declaration here");
		GTOKEN;λα@PH&∩ε%αRJ}u*20b∀*∞>J#X4($LJ→α⊗
)"R>\*91

∩Jεe∩IαR",p4($HJ
⊗≡Lq↓α∞~∞⊗N≥y∞J⊗5"fA-≤
JJRM↓l4(HH$&ε∃∩∩⊗∞ezRJV+YαNfl
∞∞Nz~εJJ
Il4(HH&⊗:"α⊗2N*αNR>\*:}R∃*∃l4PH&∩=∧∩⊗≡&r↓∨↔"β3'O"β?→βεKπ7/#↔KM⊂h($%α↓α&:$*≡⊗I∧Il4(HI↓↓αL1α:ε∀:MyEααR"⊗rα⊗JJ⎇⊃!
∂∞sQβS∞[∃β7␈∪∃βSF9↓EαβCπK∞k↔S↔↔→	%lhP$%↓αα≡R>\*9l4PH$$%
β;?]ε≠#↔∂Zβ'→β>)β#π6)βWO.!βS#O→β↔6{K∃↓Xh($%α↓α&→∧r>Q!≥">.⊗qZV:∩,~2εJ, bRf∧)α>Iα~R>.,pn&⊂E"fB∃JαR"⊗ph($$L*JJ>∩A
;↔.!βW;&+∂3π⊗+⊃β?∩β'⊃β&{/↔9εC↔K∃∩Il4(HI↓↓α4zIα&{	αNR-↓↓Eα,rR&1∧rεJ≡~α∩=hP$$&L1α⊗F*BR>.,q2εJ<rε6⊗\Ju%α$B⊗9α$z:∃lhP$%↓αα&→α-
U"R|Z⊗92
">.⊗rIαR",qα&}t
J≡MXh($%α↓α&→∧Hn:ε∀:M-E¬""⊗9∧*JJ>∩BR>.,q→	βFMβπg∪↔π∪Jβ↔↔rβWO↔"β'9β&C'Mβπ∪?∂↔'+K∃	KX4($J↓↓α:
∩≡N}t
J≡M[	l4(HI↓↓α%JB⊗nt
J≡Nmz∞Rf∧)mαε≤~⊗NN\rεJ≡≥j}∞ε≤~⊗NMXh($%α↓αεJ<rε6⊗\rεJ≡≥j}R>\*9l4PH%↓↓∧
J≡>42n:ε∀:Nv⎇B"R6B|2~⎇∩$jB>~2YE%lhP$%↓αα&→α
∩J∩⊗≤aαR",p4($HJ
⊗≡Lq↓π↔∪πeβNqβπK?+7↔;"β3'O"⊂4($HI↓αJ¬"I"⊗EαI⊃&+X4($HI↓α&u"⊗≡⊗∩α%mαMyAl4PH$%↓¬:>J⊂E∩⊗ε⊃B∩m	%Xh($$J↓α∩=∧∩⊗≡&r↓;=ε{→βπ⊗;W7↔w#Mλ4PH$%↓α↓↓↓α-y⊃∩≡$
:f⊗E↓!≠␈⊃β≠'.c⊃β?2βπKK∂Iβ∪↔≡cπKπ&K?9	b~N
%Xh($$J↓↓↓↓αα↑>J!BJ⊗ε"A	i	KX4($HI↓↓↓α↓α⊗⎇""≡RεuJ⊗bAB∪≠?Iε#'7↔w≠'?9ε3'↔3"β?→β∂∪Kπeε#↔
	b~N
%Xh($$J↓↓↓↓αα&}%[	l4(HH%↓↓α↓↓α≡$z.⊗9Xh($$J↓↓↓↓αα&→α$z.⊗8Z⊃1	αr⊃αR|Z⊗8m∃i	αRD*9α⊗∃∩>I!∀s↔↔⊃αaβ?I¬iβ#↔⊗)	%lhP$$%α↓↓α⊗t!↓;zβ?→β∂∪∨W7.sSM	¬*:R&bαR>.,qu
u∪X4($HJ&→αKqUαRD*9α⊗∃∩>I!∀KKπJβ∪'7.sO'?rβ7WO"β∃βf+OMβ&Cπ9↓*⊃%l4PH$&ε∃∩εfJ,→i∞∩Ljn∩ε%αRJ}t*\bJ,~>J⊃D
JJεM∩⊗
&mzεJJ$J6n:
∩≡Nv|Il4(HH&⊗:"↓πK⊗eβ'rβπK∨.k↔;Qεc'OQ∪X4($J↓↓αNLj
>1Tz~~N-"nNfl
JJnt
J≡Nmz6,b≥J5"ε∀::ε6-Z:εJ=~u04PH$&RMα⊗n:
∩≡Nud"εRB%⊃2Nfl
∞∞MMh&⎇↓%"6B>41l4(HI↓↓α=">.⊗sX4($J↓↓α⊗t!↓∨/!β3'∨!β?→πβπKπn+S↔K~⊃αV:$J1αR|Z⊗8m∩a	l4PH%↓↓∧J→αR|Z⊗8m∩I	αεt!αR>\*8m	Z⊃αR",qα⊗J∀zI!
v+↔⊃↓Zβ?I↓bβ?I↓Jβ#↔K*⊃%l4PI↓↓↓∧*:⊃↓↔βK?∂.#WK∃π;'S!πβπKπn+S↔K~⊃αV:$J1αR|Z⊗9u∩Iλ4(L*2N∃¬~R>.,r}RJ,)l4(M:>J⊂E∩⊗ε⊃B⊃m	%Xh(&B≥J6}6YBBI"t
J≡Md
J≡:j∃2RMα∃2ε≤~⊗NMd
JJ∩Li%l4PJNf6|~VJB∀z∞}6YBNf5D
R>.,q2>
%JB∃2¬~f51≥αJ>∞,"VJ∃KX4(&≥J6
>cR>~~≤*Rn∞-∩BJ>≥j⎇∩NLj>~→Xh(&∞-∩
2>≤Z}
2|~.&~JB:εJ=→2Nfl
JI%Xh(&
dz∞.J,→j2⊗4*2n∞-∩
2>≤Zv⎇∩d*Z⊗1Xh(&B∀z∩f}∧
JN∃Xh(&B⊃BNεZ*BBNfja∩∞2u~εZ∃KX4(%""B∞>$*⎇∩B∀~∩∞2∧~>∩∃E~f52∧∩>∩eKX4(&,rNf5"BNf5KX4(%%~f6>42⎇∩NLj>~→[	l4)I∩∞>mα&2⊗z"∞>6∧J2∃5X4*⊗t!l4(hQ¬βC∂∪O↔Mπ##∃β&+∂3π⊗S'?rβ';O'∪W∂SN{;L4PH&N∞bεI↓fK⊃y1fK⊃y1rq84(HJZ⊗∞$zI↓sN!y1sN!y19rp4($L2Jε6*↓↓s'#q1s'#q199ph($&∀zQ↓↓α↓s'⊃ras'⊃ra998hP$&⊗4*:Q↓βc'⊃ycc'⊃ybq99lhR&:R-∩:ε1¬αJ>∞,"VJ∃¬~&6Bd*∩⊗∞bB&:R,:⊗Iα|∩RfB*Il4(L∩⊗≡&ph(&J¬"I"NLj
>1L
JJεJαNBR∃YEiE¬il4(LJ:R⊗<*Iα%dQmα*{↓l4(L"=α
,:&9↓∀	λ4(J↓↓α&2α)uEααR"⊗rα⊗JJ⎇⊃!
∂∞qβ?;gIβ∪↔≡cπK∃β	Aβ[∂∪'πf+Mβ'rβ¬β∪.≠3πK∂#'?9∩Il4(J↓↓α≡$z.⊗9Z↓↓↓↓h(%↓αα&→↓D~VJ
dz∞-vu*20b∀*∞>J"αε:⊃α~R>.,pnV:$*∞2ε∀*⊂bRMα∃$4PI↓↓↓αα>I↓D~VJ
dz∞,nu*20b∀*∞>J"αε:⊃α"2⊗Z,avR>\*:2⊗4*1$4PI↓↓↓α↓αR",qα⊗J∀zI!.s∪↔∂fK↔⊃εK∪↔;&K≠'↔∩βK↔G.KK↔⊃∩H4)J↓↓↓↓αα⊗2N*α
⊗≡Lq↓∂F+∂-β∨+KK↔w!β3'∨!λ4(HH&&:$*≡⊗I∧Yl4(HH&~>∩α.⎇E¬~R⊗Aβ	αV:$J1α)∧"<4(HH$&&2α⊗FUE~f6
|ajB:j⊗nN¬"Jn.mi2R>\*9%α$B⊗9α$z:∃lhP$$&L1α-vRYEαRD*9αN¬"Jn*|Q-Fv|r:↑IE">.⊗rb>
RMα∃$4PH$$&,bN∃α-∩J>IE">.⊗r1	β'~β;?Qπ+;∪↔≡cπK↔"⊃%l4PH%↓↓∧*:⊃↓⊗≠#↔∂Zβ∂WK⊗+;QβfKOQ	Xh(%↓αα≡R>\*9"~bN∃%Xh(%↓αα&→α$z.⊗8Z⊃1	αr⊃α:⎇!α~&t
04(J↓↓↓↓ααR"⊗rα⊗JJ⎇⊃!	mε{I↓1π∪↔GWO∪↔⊃	KX4(%α↓α⊗:"↓
¬	¬*:R&bα~&:al4(LJ→α∞-∩
2>≤X4(%ααR"⊗rα~>I∧J⎇Eα≥"⊗A↓
αV:RLaα)α$y4(HJ
⊗≡Lqα&:≥∩RNfm"J⊗∃E~BRJ\Ju2∞-∩
2>≤Y%l4PH$&NLj
>1Tz~~N-"nNB%∩n&vmy!∩Rmα>~~z"R6B|2→-EKX4($HI⊃∩B≤z∩⊗⎇%~6B∩≤bB∞>$)">
%JB∃2;
			STOKEN←TRUE;
		END
	  ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
	$DISPLAYLIST[OBTYPE]←NULL;
	END;

	! to handle array declarations;
INTERNAL PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
    BEGIN "array declaration"
    RPTR(EXPR$)PARRAY;
    INTEGER NARRAY;
    RPTR(EXPR$) ARRAY PLIST[1:10];
    RPTR(SYMBOL) ARRAY SYMLST[1:10];
    NARRAY←0;
    DO BEGIN "get another one"
	STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
	RPTR(ARRAYREC) DIMREC;
	IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
	ADIM←0; GTOKEN;
	IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
	  OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
	  THEN ERROR("Need undeclared identifier for array declaration");
	ATOKEN←TOKEN; WORD_READ("[");
	DO BEGIN
	   IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
	   BOUNDS[ADIM*2+1]←$$GTANYEXP("for array dimension",#SC);
	   WORD_READ(":"); BOUNDS[ADIM*2+2]←$$GTANYEXP("for array dimension",#SC);
	   GTOKEN;
	   IF TOKEN≠"," AND TOKEN≠"]"THEN ERROR("Need , here"); ADIM←ADIM+1;
	   END UNTIL TOKEN="]";
	PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(BOUNDS,OBTYPE,ADIM,
		NARRAY +(IF CURBLOCK THEN $TMPOFF ELSE $SYMOFF-1));
	ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
	SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
	GTOKEN(FALSE);
	IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
    END UNTIL FINAL;
    IF TOKEN=";" THEN STOKEN←TRUE;
    PARRAY←NULL_RECORD;
    IF CURBLOCK THEN
	BEGIN INTEGER I; RPTR(SYMBOL)S;
		FOR I←1 STEP 1 UNTIL NARRAY DO
			BEGIN
			INSRTSYMTREE(S←SYMLST[I],CURBLOCK);
			SYMBOL:OFFSET[S]←($TMPOFF←$TMPOFF+1);
			PARRAY←$APPEND(PARRAY,PLIST[I]);
			END;
	END
    ELSE BEGIN
	INTEGER I; RPTR(SYMBOL)TEMP;
		FOR I← 1 STEP 1 UNTIL NARRAY DO
			BEGIN
			ENSYM$(TEMP←SYMLST[I]);
			SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
			PARRAY←$APPEND(PARRAY,PLIST[I]);
			END;
	END;
    $$PCODE←PARRAY;
    END "array declaration";



INTERNAL PROCEDURE DECLPROC (INTEGER OBTYPE);
	BEGIN
	GTOKEN;
	IF EQU(TOKEN,"PROCEDURE")
	    THEN PROCDECLPROC(OBTYPE)
	    ELSE IF EQU(TOKEN,"ARRAY")
		THEN ARRAYDECLPROC(OBTYPE)
		ELSE BEGIN
			STOKEN←TRUE;
			SIMPLEDECL(OBTYPE);
		     END;
	END;

INTERNAL PROCEDURE RETURNPROC;
	BEGIN RPTR(EXPR$)EXP;
	IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
	EXP←NULL_RECORD; GTOKEN;
	IF TOKEN="(" THEN
		BEGIN EXP←$$GTEXPR; GTOKEN;
		      IF TOKEN≠")" THEN ERROR("Need right paren here");
		END
	ELSE STOKEN←TRUE;
	$$PCODE←$RTNPCODE(EXP);
	END;
!	setbase,wrist,gather,readwrist,setstiff;

INTERNAL PROCEDURE SETBASEPROC;
	$$PCODE←$SETBASEPCODE;

INTERNAL PROCEDURE WRISTPROC;
BEGIN	RPTR(SYMBOL) S;
	WORD_READ("("); GTOKEN;
	IF TOKENPTR=NULL_RECORD OR
		SYMBOL:TYPE[TOKENPTR]≠#SC OR
		SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
		OR ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]≠1
		THEN ERROR("Need one dimensioned scalar array in WRIST");
	S←TOKENPTR; WORD_READ(")");
	$$PCODE←$WRISTPCODE(S);
END;

IFC #GATHER THENC

PRESET_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];

INTERNAL PROCEDURE GATHERPROC;
BEGIN	INTEGER STATUS,I; INTEGER S1;
	WORD_READ("("); STATUS←0;
	DO BEGIN
	    GTOKEN;
	    FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
	    IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
	    STATUS←STATUS LOR ('1 LSH I);
	    GTOKEN;
	END UNTIL TOKEN≠",";
	IF TOKEN≠")" THEN ERROR("Need right paren here");
	$$PCODE←$GATHERPCODE(STATUS);
END;
ENDC

IFC #WRIST THENC
INTERNAL PROCEDURE READWRISTPROC;
	BEGIN STRING COMMAND,FNAME; INTEGER VAL;
	IF $COMPILE≠0 THEN PRINT(CRLF,"WARNING: you should not put READWRIST
inside a block...",crlf,"We make no promises",CRLF);
	VAL←0;FNAME←NULL;
	WORD_READ("(");
	GTOKEN;
	COMMAND←TOKEN;
	IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
		BEGIN
		GTOKEN;
		IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
		IF EQU(COMMAND,"CALIB") THEN
			BEGIN
			GTOKEN;
			VAL←INTSCAN(TOKEN,$BRCHR);
			IF VAL<1 OR VAL>6
				THEN ERROR("Calib code must be between 1 and 6");
			END
		ELSE FNAME←NAMEFILE;
		END
	ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
		BEGIN
		STRING S; S←NULL;
		GTOKEN;
		IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
		GTOKEN;
		IF TOKEN≠"""" THEN ERROR("need double quote here");
		GTOKEN;
		WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
		FNAME←S;
		END;
	WORD_READ(")");
	GTOKEN(FALSE);
	IF NOT FINAL THEN ERROR("This is an incomplete instruction")
	ELSE IF EQU(COMMAND,"READ") THEN
		$$PCODE←$RFORCEPCODE
	ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
		ERROR("ERROR in reading wrist",$WRMSG[VAL]);
	END;
ENDC

INTERNAL PROCEDURE SETSTIFFPROC;
BEGIN
	RPTR(EXPR$) ARRAY E[1:8];
	INTEGER NARGS;
	WORD_READ("("); NARGS←0;
	DO BEGIN
	    E[NARGS←NARGS+1]←$$GTANYEXP("argument in SETSTIFF",#SC);
	    GTOKEN;
	END UNTIL TOKEN≠"," OR NARGS=6;
	IF TOKEN≠"," THEN ERROR("Need comma here")
		ELSE E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
	GTOKEN;
	IF TOKEN≠")" THEN ERROR("Need right paren after 7th argument");
	E[8]←$SETSTFPCODE; 
	$$PCODE←$AAPPEND(E);
END;


INTERNAL PROCEDURE DDTPROC;
	$$PCODE←$DDTPCODE;

! 	vt05,print,prompt,abort,sigwait;

INTERNAL PROCEDURE VT05PROC(INTEGER STATE);
	$$PCODE←$VT05PCODE(STATE);

RPTR(EXPR$)PROCEDURE PRINTCODE;
	BEGIN
	RPTR(EXPR$)P; P←NULL_RECORD;
	WORD_READ("(");
	DO BEGIN
	   GTOKEN;
	   IF TOKEN=dquote
	   THEN	BEGIN "string found"
		READTILL(dquote);
		P←$APPEND(P,$PRNPCODE(TOKEN))
		END
	   ELSE BEGIN "expression found"
		STOKEN←TRUE;
		P←$APPEND(P,$PRVPCODE($$GTEXPR));
		END;
	   GTOKEN;
	   END UNTIL TOKEN≠",";
	IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
	RETURN(P);
	END;

INTERNAL PROCEDURE PRINTPROC;
	$$PCODE←PRINTCODE;

INTERNAL PROCEDURE ABORTPROC;
	$$PCODE←$APPEND(PRINTCODE,$ABORTPCODE);

INTERNAL PROCEDURE PROMPTPROC;
	$$PCODE←$APPEND(PRINTCODE,$PROMPTPCODE);

INTERNAL PROCEDURE SIGWAITPROC(BOOLEAN SIGNAL);
	BEGIN
	RPTR(EXPR$)TEMP;rptr(symbol)sym;
	TEMP←IDREF(SYM);
	$$PCODE←$SIGWAITPCODE(TEMP,SIGNAL);
	END;
!	affix,unfix;

INTERNAL PROCEDURE UNFIXPROC;
	BEGIN
	RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
	EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
	IF SYMBOL:TYPE[FRM1]=#TR
	    THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
	    ELSE ERROR("UNFIX: need a simple trans or a frame here");
	WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
	EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
	IF SYMBOL:TYPE[FRM2]=#TR
	    THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
	    ELSE ERROR("UNFIX: need a simple trans or a frame here");
	$$PCODE←$UFXPCODE(EX1,EX2);
	END;

	! parses the instruction
	  AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};

INTERNAL PROCEDURE AFFIXPROC;
	BEGIN 
	INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
	RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
	EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
	IF SYMBOL:TYPE[FRM1]=#TR
	    THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
	    ELSE ERROR("AFFIX: need a simple trans or a frame here");
	WORD_READ("TO"); 
	EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
	IF SYMBOL:TYPE[FRM2]=#TR
	    THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
	    ELSE ERROR("AFFIX: NEED A SIMPLE TRANS OR A FRAME HERE");
	GTOKEN(FALSE);
	TEMP←NULL_RECORD;
	IF EQU(TOKEN,"AT")
	   THEN BEGIN "AT"
		TEMP←$$GTANYEXP("offset part of AFFIX statement",#FR);
		GTOKEN(FALSE);
		END "AT";
	IF FINAL 
	   THEN AFFTYPE←#RGDLK
	   ELSE BEGIN "D"
	        IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY") THEN AFFTYPE← #NRGLK
		ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY") THEN AFFTYPE← #RGDLK
		ELSE ERROR("invalid affix type");
! 	        SEMICOL_READ;  		! commented out to clean up;
	        END "D";
	$$PCODE←$AFXPCODE(EX1,EX2,AFFTYPE,TEMP);
	END ;

! 	coordproc;

INTERNAL PROCEDURE COORDPROC (INTEGER ELEMENT,TYPE);
	BEGIN
	RPTR(EXPR$) EX1,EX2; RPTR(SYMBOL) S;INTEGER TYPEF;
	S←NULL_RECORD;				! element=0,1,2,3 depending on instr;
	WORD_READ("(");
	EX1←IDREF(S);			! read the argument&look for predeclared;
	IF PRDECL(S) THEN 
		ERROR("You cannot change the value of"&SYMBOL:PNAME[S] );
	! check for correct type of argument;
	CASE (TYPEF←EXPR$:TYPE[EX1]) OF
		BEGIN
		[#SC][#RT] ERROR("unexpected type");
		[#VT] IF ELEMENT=0 THEN ERROR("unexpected type");
		ELSE 
		END;
	WORD_READ(")");
	WORD_READ("←");
	! reads the expression according to the type;
	CASE TYPE OF
		BEGIN
		[#SC] EX2←$$GTANYEXP("X-Y-Z coord",#SC);
		[#VT] EX2←$$GTANYEXP("POS",#VT);
		[#RT] EX2←$$GTANYEXP("ORIENT",#RT);
		ELSE ERROR("COORDPROC: unexpected type")
		END;
	$DISPLAYLIST[TYPEF]←NULL;
	$$PCODE←$COORDPCODE(EX1,EX2,ELEMENT,TYPE);
	END;

!	assignproc;

	! assigns to first the expression following, assuming that FIRST has not
	  been declared.  This works only for simple variables;
PROCEDURE ASGEX3(STRING FIRST);
	BEGIN RPTR(EXPR$)LHS,RHS; INTEGER TY; RPTR(SYMBOL)S; 
	RHS←$$GTEXPR;
	S←INSERT(FIRST,TY←EXPR$:TYPE[RHS]);
	LHS←EXPR$ID(S);
	$$PCODE←$ASGPCODE(LHS,RHS);
	END;

INTERNAL PROCEDURE ASGEX2(RPTR(SYMBOL)S;RPTR(EXPR$)LHS);
	BEGIN RPTR(EXPR$)RHS; INTEGER TY;
	RHS←$$GTEXPR;
	IF (TY←SYMBOL:TYPE[S])=#FR AND EXPR$:TYPE[RHS]=#TR THEN
	    EXPR$:TYPE[RHS]←#FR
	   ELSE IF TY=#TR AND EXPR$:TYPE[RHS]=#FR
		THEN CNVRTR(S,SYMBOL:PNAME[S])
	   ELSE IF EXPR$:TYPE[RHS]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
	$$PCODE←$ASGPCODE(LHS,RHS);
	END;

PROCEDURE ASGMNT(RPTR(SYMBOL)S;RPTR(EXPR$)EE);
	IF PRDECL(S) THEN
		ERROR("You cannot change the value of "&SYMBOL:PNAME[S])
		ELSE ASGEX2(S,EE);
	
INTERNAL PROCEDURE ASSIGNPROC;
	BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
	FIRST←TOKEN;  EE←NULL_RECORD;
 	IF (SS←TOKENPTR)≠NULL_RECORD THEN
		IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
			THEN BEGIN $$PCODE←PREF(TOKENPTR);
				RETURN; END
		ELSE BEGIN STOKEN←TRUE; EE←IDREF(SS); END;
	GTOKEN;
	! EE=NULL_RECORD implies is an undeclared id;
	IF TOKEN="←"
	  THEN IF EE THEN ASGMNT(SS,EE)
		     ELSE IF $LEVEL=0 THEN ASGEX3(FIRST)
				 ELSE ERROR("Cant make implicit declaration inside a block")
	   ELSE ERROR("unrecognized instruction");
	END;
! 	deflt;

INTERNAL PROCEDURE DEFLT(STRING HOW);
	BEGIN
	IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
	   THEN OPENING(OLDCMD,OLDOBJ,HOW)
	ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
		THEN IF HOW="BY"
			THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
			ELSE ERROR("BY required")
	ELSE IF EQU(OLDCMD,"DRIVE")
		THEN JTMOVE("BJT",HOW,CVD(OLDOBJ))
	ELSE IF EQU(OLDCMD,"MOVE") 
		THEN IF EQU(HOW,"BY") THEN PBYPROC ELSE PTOPROC;
	END;

END "PPROC";